home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / confirm.lisp < prev    next >
Encoding:
Text File  |  1992-05-26  |  28.2 KB  |  732 lines
  1. ;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20. ;;;
  21. ;;;  Implementation Strategy:
  22. ;;;
  23. ;;;  
  24. ;;;  A confirm is invoked by a originating contact (near). A triangular shadow originating 
  25. ;;;  from the "near" contact is drawn into the root with a given quadrant gravity, which
  26. ;;;  is dependent on the position of the originating contact. After a response is given
  27. ;;;  to confirm the area overshadowed by the confirm's shadow is refreshed over two rectangular
  28. ;;;  areas covering the overshadowed area. The sensitivity of the originating contact is turned
  29. ;;;  off when a confirm is invoked and turned back on when confirm receives a response.
  30. ;;;  
  31.  
  32.  
  33. (in-package "CLIO-OPEN")
  34.  
  35. (export '(
  36.       confirm
  37.       confirm-accept-label
  38.       confirm-accept-only
  39.       confirm-cancel-label
  40.       confirm-message
  41.       confirm-near
  42.       confirm-p
  43.       make-confirm
  44.       ))
  45.  
  46. ;; OL GUI spec for the apex of the confirm, scale-dependent distance from the originating contact)
  47. (defconstant  *confirm-apex-dimensions* (list :small 36 :medium 42 :large 50 :extra-large 64))
  48.  
  49. (defconstant  *confirm-shadow-images*
  50.           (list 
  51.         :north-west (list :upper 12%gray :lower 25%gray)
  52.         :north-east (list :upper 12%gray :lower 25%gray)
  53.         :south-west (list :upper 25%gray :lower 50%gray)
  54.         :south-east (list :upper 25%gray :lower 50%gray)
  55.         ))
  56.  
  57.  
  58. ;; Confirm scale is one scale larger than near's scale
  59. (defconstant *scales* '(:small :medium :large :extra-large :extra-large))
  60.  
  61. ;;;----------------------------------------------------------------------------+
  62. ;;;    Utility  Functions                                                      +
  63. ;;;                                                                            +
  64. ;;;----------------------------------------------------------------------------+
  65.  
  66.  
  67. (defun quadrant-gravity (x y root)
  68.   (let* ((xc (pixel-round (contact-width root) 2))
  69.      (yc (pixel-round (contact-height root) 2))
  70.      (north (< y yc))
  71.      (west  (< x xc))
  72.      )
  73.     (if north
  74.     (if west
  75.         :north-west
  76.         :north-east)
  77.     (if west
  78.         :south-west
  79.         :south-east))))
  80.  
  81. (defun find-confirm-sheet (confirm)
  82.   (car (composite-children confirm)))
  83.  
  84. ;;;----------------------------------------------------------------------------+
  85. ;;;                                                                            +
  86. ;;;  Confirm-SHEET contact                                                     +
  87. ;;;                                                                            +
  88. ;;;----------------------------------------------------------------------------+
  89.  
  90. (defcontact confirm-sheet  (core composite)
  91.   ()
  92.   (:resources
  93.     (background :initform :parent-relative)
  94.     (event-mask :initform #.(make-event-mask :exposure)))
  95.   (:documentation "The actual container for confirm component areas."))
  96.  
  97. ;;;----------------------------------------------------------------------------+
  98. ;;;                                                                            +
  99. ;;;  CONFIRM contact                                                           +
  100. ;;;                                                                            +
  101. ;;;----------------------------------------------------------------------------+
  102.  
  103. (defcontact confirm (core core-shell override-shell)
  104.   ((near         :initform nil
  105.          :type (or null contact)
  106.          :initarg :near
  107.          :accessor confirm-near
  108.          :documentation "Indicating point or contact of origination")
  109.  
  110.    (cancel-label :initform "Cancel"
  111.          :type     string
  112.          :accessor confirm-cancel-label
  113.          :initarg  :cancel-label)
  114.    
  115.    ;; Internal slots
  116.    (points       :type           (vector window) ;; storage x-near y-near & shadow regions
  117.           :initform       (make-array 6))
  118.    (previous-pointer-x
  119.                     :type (or null int16)
  120.             :initform nil)
  121.    (previous-pointer-y
  122.                     :type (or null int16)
  123.             :initform nil)
  124.    (control-default :type (or null contact)
  125.             :initform nil))
  126.   (:resources
  127.     (save-under :initform :on)
  128.     (default-control :initform :accept :type (member :accept :cancel))
  129.     (accept-label    :type string :initform "OK")
  130.     cancel-label
  131.     (border-width    :initform 1) 
  132.     (accept-only     :type (member :on :off) :initform :off)
  133.     (message         :initform "Press a button to continue."))
  134.   (:documentation "A dialog which presents a simple message."))
  135.  
  136. (defmethod (setf contact-foreground) :after (new-value (self confirm))
  137.   (setf (contact-foreground (car (composite-children self))) new-value))
  138.  
  139.  
  140. ;; Index values for accessing x-near y-near
  141. (defconstant *x-near*       0)
  142. (defconstant *y-near*       1)
  143.  
  144.  
  145. (defun make-confirm (&rest initargs)
  146.   "Creates and returns a confirm instance."
  147.   (declare (values confirm)) 
  148.   (apply #'make-contact 'confirm initargs))
  149.  
  150.  
  151. ;;;----------------------------------------------------------------------------+
  152. ;;;                                                                            +
  153. ;;; Accessors                                                                  +
  154. ;;;                                                                            +
  155. ;;;----------------------------------------------------------------------------+
  156.  
  157. (defun find-accept-button (confirm)
  158.   (find :accept (composite-children (find-confirm-sheet confirm)) :key 'contact-name))
  159.  
  160. (defun find-cancel-button (confirm)
  161.   (find :cancel (composite-children (find-confirm-sheet confirm)) :key 'contact-name))
  162.  
  163. (defun find-message-area (confirm)
  164.   (find :message (composite-children (find-confirm-sheet confirm)) :key 'contact-name))
  165.  
  166. (defmethod dialog-default-control ((self confirm))
  167.   (with-slots (control-default) self
  168.    (contact-name control-default)))
  169.  
  170. (defmethod (setf dialog-default-control) (new-value (confirm confirm))
  171.   (check-type new-value (member :accept :cancel) "one of :ACCEPT or :CANCEL")
  172.   (assert (or (eq new-value :accept) (eq (confirm-accept-only confirm) :off)) nil
  173.       "No cancel control exists for ~a." confirm)
  174.   (with-slots (control-default) confirm
  175.     (when control-default
  176.       (setf (choice-item-highlight-default-p control-default) nil))
  177.     (setf control-default
  178.       (find new-value (composite-children (find-confirm-sheet confirm)) :key #'contact-name))
  179.     (setf (choice-item-highlight-default-p control-default) t)
  180.     new-value))
  181.  
  182.  
  183. (defmethod confirm-accept-only ((self confirm))
  184.   (let ((cancel-button (find-cancel-button self)))
  185.     (if (and cancel-button (eq :mapped (contact-state cancel-button)))
  186.     :off
  187.     :on)))
  188.  
  189.  
  190. (defmethod (setf confirm-accept-only) (value (self confirm))
  191.   "Set confirm's cancel button to the appropriate setting depending on VALUE.
  192.    create the buttons if necessary."
  193.   (check-type value switch "one of :ON or :OFF")
  194.   (let* ((sheet (find-confirm-sheet self))
  195.      (cancel-button (find-cancel-button self)))
  196.     (if cancel-button
  197.     (setf (contact-state cancel-button)
  198.           (if (eq value :on) :withdrawn :mapped))
  199.  
  200.     (when (eq value :off)
  201.       (with-slots (cancel-label) self
  202.         (add-callback (make-action-button :parent sheet :name :cancel :label cancel-label)
  203.               :release 'dialog-cancel self)))))
  204.   value)
  205.  
  206.  
  207. (defmethod confirm-message ((self confirm))
  208.   (display-text-source (find-message-area self)))
  209.  
  210.  (defmethod (setf confirm-message) (string (self confirm))
  211.   (setf (display-text-source (find-message-area self)) string))
  212.  
  213. (defmethod confirm-accept-label ((self confirm))
  214.   (button-label (find-accept-button self)))
  215.  
  216. (defmethod (setf confirm-accept-label) (string (self confirm))
  217.   (setf (button-label (find-accept-button self)) string))
  218.  
  219. (defmethod confirm-cancel-label ((self confirm))
  220.   (button-label (find-cancel-button self)))
  221.  
  222. (defmethod (setf confirm-cancel-label) :after (string (self confirm))
  223.   (let ((label  (find-cancel-button self)))
  224.     (when label (setf (button-label label) string))))
  225.  
  226.  
  227. ;;;----------------------------------------------------------------------------+
  228. ;;;                                                                            |
  229. ;;;                            Initialization                                  |
  230. ;;;                                                                            |
  231. ;;;----------------------------------------------------------------------------+
  232.  
  233. (defmethod initialize-instance :after ((self confirm) &key message accept-only accept-label 
  234.                     (default-control :accept) &allow-other-keys)
  235.   (with-slots (x y width height near foreground scale)  self
  236.     (unless near (setq near self))
  237.  
  238.     ;; Create the sheet
  239.     (let* ((sheet (make-contact 'confirm-sheet :name :sheet
  240.                 :parent self
  241.                 :x 0 :y 0
  242.                 :width width :height height
  243.                 :border-width 0))
  244.        (near-scale (contact-scale near)))
  245.  
  246.       (setf scale (nth (1+ (position near-scale *scales*)) *scales*))
  247.       ;; Create the message area
  248.  
  249.       (make-display-text :name :message
  250.              :parent sheet
  251.              :source message
  252.              :alignment :center
  253.              :x 0 :y 0
  254.              :border-width 0)
  255.  
  256.       ;; Create buttons for command area
  257.       (add-callback (make-action-button :parent sheet :name :accept :label accept-label)
  258.             :release 'dialog-accept self)
  259.       
  260.       ;; Initialize cancel control if necessary
  261.       (setf (confirm-accept-only self) accept-only)
  262.             
  263.       
  264.       (setf (dialog-default-control self) default-control))))
  265.  
  266.  
  267. ;;;----------------------------------------------------------------------------+
  268. ;;;                                                                            +
  269. ;;; Dialog                                                                     +
  270. ;;;                                                                            +
  271. ;;;----------------------------------------------------------------------------+
  272.     
  273.  
  274. (defmethod dialog-accept ((self confirm))
  275.   "Invokes :accept callback function and pops down the dialogue"
  276.   (setf (contact-state self) :withdrawn)
  277.   (apply-callback self :accept)
  278.   )
  279.  
  280. (defmethod dialog-cancel ((self confirm))
  281.   "Invokes :cancel callback function and pops down the dialogue."
  282.   (setf (contact-state self) :withdrawn)
  283.   (apply-callback self :cancel)
  284.   )
  285.  
  286.  
  287.  
  288. ;;;----------------------------------------------------------------------------+
  289. ;;;                                                                            +
  290. ;;; Confirm Map : where real work happens                                      +
  291. ;;;                                                                            +
  292. ;;;----------------------------------------------------------------------------+
  293.  
  294.  
  295. ;; If the pointer moves off the Confirm don't warp pointer to Near just leave
  296. ;; where the Confirm action button was selected otherwise warp pointer to Near after
  297. ;; selecting a Confirm action button.
  298.  
  299. ;; Track the state of pointer position w.r.t Confirm by storing state in internal slot 
  300. ;; of Confirm (ie. Did it stay on the Confirm the whole time or did it move off the Confirm?).
  301.  
  302.  
  303. (defun calculate-upper-shadow-vertices (points x y gravity right-edge bottom-edge)
  304.   "Determine the two sets of points for drawing the upper triangular shadow"
  305.   (case gravity
  306.     (:north-east
  307.      (setf (svref points 2) x (svref points 3) y (svref points 4) (+ 3 right-edge) (svref points 5)  y))
  308.     (:north-west
  309.      (setf (svref points 2) x (svref points 3) y (svref points 4) right-edge (svref points 5)  (1- y)))
  310.     (:south-west
  311.      (setf (svref points 2) x (svref points 3) y (svref points 4) x (svref points 5) (+ bottom-edge 1)))
  312.     (:south-east
  313.      (setf (svref points 2) (+ right-edge 2)
  314.        (svref points 3) (+ 2 bottom-edge) (svref points 4) (+ right-edge 2) (svref points 5) y))))
  315.    
  316. (defun calculate-lower-shadow-vertices (points x y gravity right-edge bottom-edge)
  317.   "Determine the two sets of points for drawing the lower triangular shadow"
  318.   (case gravity
  319.     (:north-east
  320.      (setf (svref points 2) (+ right-edge 2)
  321.        (svref points 3) y (svref points 4) (+ right-edge 2) (svref points 5) bottom-edge))
  322.     (:north-west
  323.      (setf (svref points 2) x (svref points 3) (1- y) (svref points 4) x (svref points 5) bottom-edge))
  324.     (:south-west
  325.      (setf (svref points 2) (1- x)
  326.        (svref points 3) (+ bottom-edge 1) (svref points 4) right-edge (svref points 5) (+ bottom-edge 2)))
  327.     (:south-east
  328.      (setf (svref points 2) x
  329.        (svref points 3) (+ 2 bottom-edge) (svref points 4) (+ 2 right-edge) (svref points 5) (+ 2  bottom-edge)))))
  330.    
  331. (defun draw-confirm-triangular-shadows (confirm root x y width height points gravity)
  332.   "Draw two triangular shadows originating from NEAR given the calculated vertices"
  333.   (proclaim '(inline calculate-shadows-vertices ))
  334.   (let*
  335.       ((images (getf *confirm-shadow-images* gravity))
  336.        (upper-image (getf images :upper))
  337.        (lower-image (getf images :lower))
  338.        (bottom-edge  (+ y height))
  339.        (right-edge   (+ x width)))
  340.     (calculate-upper-shadow-vertices points x y gravity right-edge bottom-edge)
  341.     (using-gcontext
  342.      (gcontext :drawable root
  343.            :background (contact-current-background-pixel confirm)
  344.            :foreground (screen-black-pixel (contact-screen root))
  345.            :fill-style :opaque-stippled
  346.            :stipple    (contact-image-mask root upper-image :depth 1)
  347.            :subwindow-mode :include-inferiors
  348.            )      
  349.      (draw-lines root gcontext points :fill-p t :shape :complex)
  350.      (calculate-lower-shadow-vertices points x y gravity right-edge bottom-edge)
  351.      (with-gcontext (gcontext :stipple (contact-image-mask root lower-image :depth 1))
  352.        (draw-lines root gcontext points :fill-p t :shape :complex)))))
  353.   
  354. (defmethod shell-mapped ((self confirm))
  355.   "Recomputes x and y given NEAR and invokes :initialize callback function."    
  356.   (with-slots (near height width points previous-pointer-x previous-pointer-y control-default) 
  357.     self
  358.     (unless (eq self near)
  359.       (multiple-value-bind (x-near y-near)
  360.       (contact-translate near
  361.                  (pixel-round (contact-width near) 2);; Use center point of near
  362.                  (pixel-round (contact-height near) 2))
  363.     (setf (svref points *x-near*) x-near)
  364.     (setf (svref points *y-near*) y-near)
  365.     (let* ((root (contact-root self))
  366.            (gravity (quadrant-gravity x-near y-near root))
  367.            (apex    (getf *confirm-apex-dimensions* (contact-scale self)))
  368.            (root-width  (contact-width root))
  369.            (root-height (contact-height root)))
  370.  
  371.       ;; Set Confirm's X and Y w.r.t originating contact
  372.       (multiple-value-bind (x y)
  373.           (case gravity
  374.         (:north-east
  375.          (values (- x-near apex width)
  376.              (+ y-near apex)))
  377.         (:north-west
  378.          (values (+ x-near apex)
  379.              (+ y-near apex)))
  380.         (:south-west
  381.          (values (+ x-near apex)
  382.              (- y-near apex height)))
  383.         (:south-east
  384.          (values (- x-near apex width)
  385.              (- y-near apex height))))
  386.           
  387.         ;; If CONFIRM will be clipped, compensate
  388.         ;; and adjust x and y of CONFIRM
  389.         (let ((adjusted-x (min (max x 0) (- root-width width)))
  390.           (adjusted-y (min (max y 0) (- root-height height))))
  391.           (change-geometry self
  392.                    :x adjusted-x 
  393.                    :y adjusted-y 
  394.                    )
  395.           ;; Turn near's sensitivity off
  396.           (setf (contact-sensitive near) :off))))))
  397.       
  398.     (apply-callback self :map)
  399.     (apply-callback self :initialize)
  400.  
  401.     ;; Store position for pointer unwarping later....
  402.     (multiple-value-setq
  403.     (previous-pointer-x previous-pointer-y) (pointer-position self))
  404.       
  405.     (warp-pointer
  406.      control-default
  407.      (pixel-round (contact-width control-default)  2)
  408.      (- (contact-height control-default) 2))))
  409.   
  410.  
  411. (defmethod display ((manager confirm-sheet)
  412.             &optional exposed-x exposed-y exposed-width exposed-height &key)
  413.   (declare (ignore exposed-x exposed-y exposed-height exposed-width))
  414.   (proclaim '(inline draw-confirm-triangular-shadows))
  415.     
  416.   (with-slots (width height x y points) 
  417.     (contact-parent manager)
  418.     (let ((root (contact-root manager)))
  419.       (draw-confirm-triangular-shadows
  420.        manager root
  421.        x  y width height points
  422.        (quadrant-gravity (svref points *x-near*) (svref points *y-near*) root))))
  423.  
  424.   (with-slots (width height foreground)
  425.     manager
  426.     (using-gcontext (gcontext :drawable manager :foreground foreground :Subwindow-mode :include-inferiors)
  427.             (draw-rectangle manager gcontext 3 3 (- width 7) (- height 7)))))
  428.  
  429.  
  430.  
  431. (defevent confirm :leave-notify pointer-off-confirm)
  432.  
  433. (defmethod pointer-off-confirm ((self confirm))
  434.   (with-slots (previous-pointer-x) self
  435.     (setf previous-pointer-x nil)))
  436.  
  437.  
  438.  
  439. (defun calculate-reexposed-areas (confirm root)
  440.   "Determine two rectangular areas encompassing the triangular shadows drawn by confirm"
  441.   (with-slots (x y width height near points)
  442.     confirm
  443.     (let* (
  444.        (apex (getf *confirm-apex-dimensions* (contact-scale confirm)))
  445.        (x-near      (svref points *x-near*))
  446.        (y-near      (svref points *y-near*))
  447.        (right-edge  (+ x width))
  448.        (bottom-edge (+ y height))
  449.        (gravity (quadrant-gravity x-near y-near root))
  450.        )
  451.       (case gravity
  452.     (:north-east
  453.      (values
  454.       x           (- y apex) width apex
  455.       right-edge (- y apex) apex  (+ height apex))
  456.      )
  457.     (:north-west
  458.      (values
  459.       x-near y-near     apex   (+ height apex)
  460.       x     (- y apex)  width  apex)
  461.      )
  462.     (:south-west
  463.      (values
  464.       (- x apex) y           apex  (+ height apex)
  465.       x         bottom-edge width apex)
  466.      )
  467.     (:south-east
  468.      (values 
  469.       x           bottom-edge width apex
  470.       right-edge     y           apex  (+ height apex)))))))
  471.    
  472. (defun reexpose-overshadowed-area (confirm root near)
  473.   "Refresh the root area that confirm overshadowed"
  474.   (proclaim '(inline calculate-reexposed-areas))
  475.   (multiple-value-bind (area1-x area1-y area1-width area1-height
  476.                 area2-x area2-y area2-width area2-height)
  477.       (calculate-reexposed-areas confirm root)
  478.     (refresh root :x area1-x :y area1-y :width area1-width :height area1-height)
  479.     (with-slots (sensitive) near
  480.         (setq sensitive :on))
  481.     (refresh root :x area2-x :y area2-y :width area2-width :height area2-height)))
  482.  
  483. (defmethod shell-unmapped :before ((self confirm))
  484.   (proclaim '(inline reexpose-overshadowed-area))
  485.   (with-slots (points near previous-pointer-x previous-pointer-y)
  486.     self
  487.     (unless (eq self near)
  488.       ;; Erase shadow.
  489.       (reexpose-overshadowed-area self (contact-root self) near)
  490.     
  491.       ;; Unwarp pointer to original position, if necessary.
  492.       (when previous-pointer-x
  493.     (warp-pointer self previous-pointer-x previous-pointer-y)))))
  494.  
  495.  
  496. ;;;----------------------------------------------------------------------------+
  497. ;;;                                                                            +
  498. ;;;  Geometry Management                                                       +
  499. ;;;                                                                            +
  500. ;;;----------------------------------------------------------------------------+
  501.  
  502. (defmethod change-layout ((self confirm-sheet) &optional newly-managed)
  503.   ;;The idea here is to make the accept and cancel buttons be separated by the
  504.   ;;standard horizontal spacing, and then centered within the sheet.  The standard 
  505.   ;;vertical spacing will be enforced between the bottom edge of the taller button
  506.   ;;and the edge of the message.
  507.   ;;Force the message area to be the smaller of its preferred size or the space remaining
  508.   ;;(allowing for horizontal/vertical margins).  Center it within the remaining space.
  509.   (declare (ignore newly-managed))
  510.   (with-slots (width height children parent) self
  511.     (let* ((accept-button (find-accept-button parent))
  512.        (cancel-button (find-cancel-button parent))
  513.        (message-area  (find-message-area  parent))
  514.        (abw (contact-border-width accept-button))
  515.        (awidth (+ abw abw (contact-width accept-button)))
  516.        (aheight (+ abw abw (contact-height accept-button)))
  517.        (screen (contact-screen self))
  518.        (pixel (getf *dialog-point-spacing* (contact-scale self)))
  519.        (hspace (point-pixels screen pixel :horizontal))    
  520.        (vspace (point-pixels screen pixel :vertical))
  521.        rbw rwidth rheight button-x button-y) 
  522.  
  523.       ;;Figure out where buttons should go.  Make their top edges align.
  524.       (if (eq (confirm-accept-only (contact-parent self)) :on)
  525.       (progn
  526.         (setf button-y (- height aheight vspace)
  527.           button-x (floor (- width awidth) 2))
  528.         (move accept-button  button-x button-y)
  529.         )
  530.       (progn 
  531.         (setf rbw (contact-border-width cancel-button)
  532.           rwidth (+ rbw rbw (contact-width cancel-button))
  533.           rheight (+ rbw rbw (contact-height cancel-button))
  534.           button-y (- height (+ (max aheight rheight) vspace 3))       
  535.           button-x (floor (- width (+ awidth rwidth hspace 3)) 2))
  536.         (with-state (accept-button)
  537.           (move accept-button  button-x  button-y)
  538.           )
  539.         (incf button-x (+ awidth hspace))
  540.         (with-state (cancel-button)
  541.           (move cancel-button button-x button-y)
  542.           )
  543.         )
  544.       )
  545.  
  546.       (IF (or (zerop width) (zerop height) )            ; not initialized...
  547.       (multiple-value-bind (p-width p-height)
  548.           (preferred-size self)
  549.         (change-geometry self :width p-width :height p-height :accept-p t))
  550.       ;; else...
  551.       
  552.       ;;Make message-area fit within space remaining
  553.       (with-state (message-area)
  554.         (let ((new-width  (max 1
  555.                    (- width hspace hspace)
  556.                    ))
  557.           (new-height (max 1 (- button-y vspace vspace)))
  558.           )
  559.           (resize message-area
  560.               new-width     ;;use 1 as a lower bound to prevent
  561.               new-height    ;;width/height sizing errors
  562.               0)
  563.           ;;Center message-area within space remaining.
  564.           ;;Don't have to worry about it's border-width since it's guaranteed
  565.           ;;to be zero by the previous call to RESIZE.
  566.           (move message-area
  567.             (max hspace (floor (- width (contact-width message-area)) 2))
  568.             (max vspace (floor (- (contact-y accept-button) (contact-height message-area)) 2)))))
  569.       ))))
  570.  
  571.  
  572.  
  573. (defmethod resize :after ((self confirm-sheet) width height border-width)
  574.   (declare (ignore width height border-width))
  575.   (change-layout self))
  576.  
  577. (defmethod manage-geometry ((self confirm-sheet) (child contact)
  578.                 x y width height border-width &key) 
  579.   (let (success-p)
  580.     (multiple-value-bind (p-w p-h p-b-w)
  581.     (preferred-size self)
  582.       (if  (or 
  583.          (/= p-w  (contact-width self))
  584.          (/= p-h  (contact-height self))
  585.          (and width  (/= width  (contact-width child)))
  586.          (and height (/= height (contact-height child)))
  587.          )
  588.        (setf success-p  #'(lambda (self)
  589.                    (progn (change-geometry self
  590.                                :width p-w
  591.                                :height p-h
  592.                                :border-width p-b-w
  593.                                :accept-p t)
  594.                       (change-layout self))))
  595.        (setf success-p t)))
  596.     (values success-p
  597.         (or x (contact-x child))
  598.         (or y (contact-y child))
  599.         (or width (contact-width child))
  600.         (or height (contact-height child))
  601.         (or border-width (contact-border-width child)))))
  602.       
  603.  
  604.  
  605. (defmethod preferred-size ((self confirm-sheet) &key width height border-width)
  606.   (declare (ignore width height border-width))
  607.   (with-slots (children parent) self
  608.     (let* ((accumulated-width 0)
  609.        (highest 0)
  610.        (apply-button  (find-accept-button parent))
  611.        (cancel-button (find-cancel-button parent))
  612.        (message-area  (find-message-area  parent))
  613.        (screen (contact-screen self))
  614.        (pixel (getf *dialog-point-spacing* (contact-scale self)))
  615.        (hspace (point-pixels screen pixel :horizontal))
  616.        (vspace (point-pixels screen pixel :vertical)))
  617.  
  618.       ;;Find out how much space the buttons will need.
  619.       ;;Remember: buttons are in a row, so we're interested in combined width
  620.       ;;          and the maximum height
  621.       (multiple-value-bind (pwidth1 pheight1 pbw1)
  622.       (preferred-size apply-button)
  623.     (setf accumulated-width (+ pwidth1 pbw1 pbw1)
  624.           highest (+ pheight1 pbw1 pbw1))
  625.     (when (eq (confirm-accept-only (contact-parent self)) :off)
  626.       (multiple-value-bind (pwidth2 pheight2 pbw2)
  627.           (preferred-size cancel-button)
  628.         (setf accumulated-width (+ accumulated-width hspace pwidth2 pbw2 pbw2)
  629.           highest (max highest (+ pheight2 pbw2 pbw2))))))
  630.       
  631.       ;;We can ignore the preferred border-width because confirm-sheet
  632.       ;;geometry management forces a zero-width border.
  633.       (multiple-value-bind (pwidth pheight)
  634.       ;; Use width/height 0 to request minimum text extent size.
  635.       (preferred-size message-area :width 0 :height 0) 
  636.     (values (+ (max pwidth accumulated-width) hspace hspace 6)
  637.         (+ pheight highest vspace vspace vspace 6)
  638.         0))))) 
  639.  
  640.  
  641. ;;;----------------------------------------------------------------------------+
  642. ;;;                                                                            +
  643. ;;;   WITH-CONFIRM     Using cached confirms                                   +
  644. ;;;                                                                            +                        
  645. ;;;----------------------------------------------------------------------------+
  646.  
  647.  
  648. (defmacro top-level-confirms (top)
  649.   "A list of confirm contacts associated with TOP."
  650.   `(getf (window-plist ,top) :confirm-cache))
  651.  
  652.  
  653. (defun confirm-p (&rest initargs &key near &allow-other-keys)
  654.   "Bind a confirm to the given initargs either by allocating one from
  655.    the confirm cache if one exists or instantiate one"
  656.   (assert near () "A :near initarg was not provided for CONFIRM-P")
  657.   (let* ((near-scale (contact-scale near))     
  658.      (top-level  (contact-top-level near))
  659.      (background (getf initargs :background))
  660.      (confirm    (pop (top-level-confirms top-level)))
  661.      (display    (contact-display near)))
  662.  
  663.     (setf background
  664.       (if background
  665.           (convert near background '(or (member :none :parent-relative) pixel pixmap))
  666.           (contact-current-background-pixel top-level)))
  667.  
  668.     (if confirm
  669.     (let ((foreground      (getf initargs :foreground))        
  670.           (accept-label    (getf initargs :accept-label))
  671.           (cancel-label    (getf initargs :cancel-label))
  672.           (accept-only     (getf initargs :accept-only))
  673.           (message         (getf initargs :message))
  674.           (near            (getf initargs :near))
  675.           (default-control (getf initargs :default-control)))
  676.       
  677.       (setf (contact-background confirm) background)
  678.       
  679.       (setf (contact-foreground confirm)
  680.         (convert near
  681.              (or foreground :black)
  682.              '(or (member :none :parent-relative) pixel pixmap)))      
  683.       (setf (confirm-accept-label confirm)
  684.         (if accept-label
  685.             (convert near accept-label 'string)
  686.             "OK"))
  687.       (setf (confirm-accept-only confirm)
  688.         (if accept-only
  689.             (convert near accept-only '(member :on :off))
  690.             :off))
  691.       (setf (confirm-cancel-label confirm)
  692.         (if cancel-label
  693.             (convert near cancel-label 'string)
  694.             "Cancel"))
  695.       (setf (confirm-message confirm)
  696.         (if message
  697.             (convert near message 'string)
  698.             "Press a button to continue."))
  699.       (setf (confirm-near confirm) near)
  700.       (setf (dialog-default-control confirm)
  701.         (if default-control
  702.             (convert near default-control '(member :accept :cancel))
  703.             :accept))
  704.       (setf (contact-scale confirm)
  705.         (nth (1+ (position near-scale *scales*)) *scales*)))
  706.  
  707.     (setf confirm
  708.           (apply
  709.         #'make-confirm
  710.         :parent top-level
  711.         :background background
  712.         :scale near-scale
  713.         :callbacks `((:accept (,#'(lambda () (throw :exit-confirm t))))
  714.                  (:cancel (,#'(lambda () (throw :exit-confirm nil)))))
  715.         initargs))) 
  716.  
  717.     
  718.     (setf (contact-state confirm) :mapped)
  719.     (unwind-protect
  720.     (catch :exit-confirm
  721.       (loop (process-next-event display)))
  722.       (push confirm (top-level-confirms top-level)))))
  723.  
  724.  
  725. (defmethod present-dialog ((confirm confirm) &key x y button state)
  726.    (declare (type (or card16 null) x y)
  727.         (type (or (member :button-1 :button-2 :button-3 :button-4 :button-5) null) button)
  728.         (type (or mask16 null) state))
  729.    (declare (ignore button state x y))
  730.    (setf (contact-state confirm) :mapped))
  731.  
  732.